home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libcruft / ranlib / phrtsd.f < prev    next >
Text File  |  1996-07-19  |  2KB  |  85 lines
  1.       SUBROUTINE phrtsd(phrase,seed1,seed2)
  2. C**********************************************************************
  3. C
  4. C     SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 )
  5. C               PHRase To SeeDs
  6. C
  7. C
  8. C                              Function
  9. C
  10. C
  11. C     Uses a phrase (character string) to generate two seeds for the RGN
  12. C     random number generator.
  13. C
  14. C
  15. C                              Arguments
  16. C
  17. C
  18. C     PHRASE --> Phrase to be used for random number generation
  19. C                         CHARACTER*(*) PHRASE
  20. C
  21. C     SEED1 <-- First seed for RGN generator
  22. C                         INTEGER SEED1
  23. C
  24. C     SEED2 <-- Second seed for RGN generator
  25. C                         INTEGER SEED2
  26. C
  27. C
  28. C                              Note
  29. C
  30. C
  31. C     Trailing blanks are eliminated before the seeds are generated.
  32. C
  33. C     Generated seed values will fall in the range 1..2^30
  34. C     (1..1,073,741,824)
  35. C
  36. C**********************************************************************
  37. C     .. Parameters ..
  38.       CHARACTER*(*) table
  39.       PARAMETER (table='abcdefghijklmnopqrstuvwxyz'//
  40.      +          'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'//
  41.      +          '!@#$%^&*()_+[];:''"<>?,./')
  42.       INTEGER twop30
  43.       PARAMETER (twop30=1073741824)
  44. C     ..
  45. C     .. Scalar Arguments ..
  46.       INTEGER seed1,seed2
  47.       CHARACTER phrase* (*)
  48. C     ..
  49. C     .. Local Scalars ..
  50.       INTEGER i,ichr,j,lphr
  51. C     ..
  52. C     .. Local Arrays ..
  53.       INTEGER shift(0:4),values(5)
  54. C     ..
  55. C     .. External Functions ..
  56.       INTEGER lennob
  57.       EXTERNAL lennob
  58. C     ..
  59. C     .. Intrinsic Functions ..
  60.       INTRINSIC index,mod
  61. C     ..
  62. C     .. Data statements ..
  63.       DATA shift/1,64,4096,262144,16777216/
  64. C     ..
  65. C     .. Executable Statements ..
  66.       seed1 = 1234567890
  67.       seed2 = 123456789
  68.       lphr = lennob(phrase)
  69.       IF (lphr.LT.1) RETURN
  70.       DO 30,i = 1,lphr
  71.           ichr = mod(index(table,phrase(i:i)),64)
  72.           IF (ichr.EQ.0) ichr = 63
  73.           DO 10,j = 1,5
  74.               values(j) = ichr - j
  75.               IF (values(j).LT.1) values(j) = values(j) + 63
  76.    10     CONTINUE
  77.           DO 20,j = 1,5
  78.               seed1 = mod(seed1+shift(j-1)*values(j),twop30)
  79.               seed2 = mod(seed2+shift(j-1)*values(6-j),twop30)
  80.    20     CONTINUE
  81.    30 CONTINUE
  82.       RETURN
  83.  
  84.       END
  85.